home *** CD-ROM | disk | FTP | other *** search
/ Hardcore Visual Basic 5.0 (2nd Edition) / Hardcore Visual Basic 5.0 - Second Edition (1997)(Microsoft Press).iso / Code / Version.cls < prev    next >
Text File  |  1997-06-14  |  11KB  |  376 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "CVersion"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = True
  10. Option Explicit
  11.  
  12. Public Enum EErrorVersion
  13.     eeBaseVersion = 13410   ' CVersion
  14. End Enum
  15.  
  16. ' Internal class data
  17. Private sExeName As String
  18. Private sVer As String
  19. 'Private cVer As Long, cVer2 As Long ' cVer2 for alignment (not used)
  20. Private pData As Long, cData As Long
  21. Private fixed As VS_FIXEDFILEINFO
  22. Private sPrefix As String
  23.  
  24. ' Create new Version object
  25. Sub Create(sExeNameA As String)
  26.  
  27.     ' If it already exists, destroy it
  28.     If sVer <> sEmpty Then ReInit
  29.  
  30.     Dim hVer As Long, cVer As Long
  31.     ' Get size and handle of version data
  32.     cVer = GetFileVersionInfoSize(sExeNameA, hVer)
  33.     If cVer = 0 Then
  34.         ' No error means file has no resources
  35.         If Err.LastDllError = 0 Then Exit Sub
  36.         ErrRaise Err.LastDllError
  37.     End If
  38.     sVer = String$(cVer, 0)
  39.     Dim f As Long
  40.     f = GetFileVersionInfo(sExeNameA, hVer, cVer, sVer)
  41.     If f = 0 Then ErrRaise Err.LastDllError
  42.  
  43.     ' Get fixed portion of data
  44.     f = VerQueryValue(sVer, "\", pData, cData)
  45.     If f = 0 Then ErrRaise Err.LastDllError
  46.     BugAssert cData = Len(fixed)
  47.     CopyMemory fixed, ByVal pData, Len(fixed)
  48.  
  49.     ' Get version as hex number with low and high reversed
  50.     f = VerQueryValue(sVer, "\VarFileInfo\Translation", pData, cData)
  51.     If f = 0 Then ErrRaise Err.LastDllError
  52.     If cData = 0 Then
  53.         ' No version information
  54.         ReInit
  55.         Exit Sub
  56.     End If
  57.  
  58.     ' Success - copy internal data to prefix and exe name
  59.     CopyMemory cVer, ByVal pData, cData
  60.     ' Version APIs are extremely picky about format of this string
  61.     sPrefix = "\StringFileInfo\" & _
  62.               MUtility.FmtHex(MBytes.LoWord(cVer), 4) & _
  63.               MUtility.FmtHex(MBytes.HiWord(cVer), 4) & "\"
  64.     sExeName = sExeNameA
  65.     
  66. End Sub
  67.  
  68. ' Change file associated with an existing version object
  69.  
  70. Property Let ExeName(sExeNameA As String)
  71. Attribute ExeName.VB_UserMemId = 0
  72.     ReInit
  73.     Create sExeNameA
  74. End Property
  75.  
  76. Property Get ExeName() As String
  77.     ExeName = sExeName
  78. End Property
  79.  
  80. Private Sub ReInit()
  81. With fixed
  82.     sExeName = sEmpty
  83.     sVer = sEmpty
  84.     .dwSignature = 0&
  85.     .dwStrucVersion = 0&
  86.     .dwFileVersionMS = 0&
  87.     .dwFileVersionLS = 0&
  88.     .dwProductVersionMS = 0&
  89.     .dwProductVersionLS = 0&
  90.     .dwFileFlagsMask = 0&
  91.     .dwFileFlags = 0&
  92.     .dwFileOS = 0&
  93.     .dwFileType = 0&
  94.     .dwFileSubtype = 0&
  95.     .dwFileDateMS = 0&
  96.     .dwFileDateLS = 0&
  97. End With
  98. End Sub
  99.  
  100. Private Function BufToStr(pBuf As Long, cBuf) As String
  101.     Dim s As String
  102.     s = String$(cBuf + 1, 0)
  103.     If UnicodeTypeLib Then
  104.         CopyMemoryToStr s, ByVal pBuf, cBuf * 2
  105.     Else
  106.         CopyMemoryToStr s, ByVal pBuf, cBuf
  107.     End If
  108.     BufToStr = MUtility.StrZToStr(s)
  109. End Function
  110.  
  111. Property Get FullFileVersion() As String
  112.     If sVer = sEmpty Then
  113.         FullFileVersion = sEmpty
  114.     Else
  115.         FullFileVersion = MBytes.HiWord(fixed.dwFileVersionMS) & "." & _
  116.                           MBytes.LoWord(fixed.dwFileVersionMS) & "." & _
  117.                           MBytes.HiWord(fixed.dwFileVersionLS) & "." & _
  118.                           MBytes.LoWord(fixed.dwFileVersionLS)
  119.     End If
  120. End Property
  121.  
  122. Property Get FullProductVersion() As String
  123.     If sVer = sEmpty Then
  124.         FullProductVersion = sEmpty
  125.     Else
  126.         FullProductVersion = MBytes.HiWord(fixed.dwProductVersionMS) & "." & _
  127.                              MBytes.LoWord(fixed.dwProductVersionMS) & "." & _
  128.                              MBytes.HiWord(fixed.dwProductVersionLS) & "." & _
  129.                              MBytes.LoWord(fixed.dwProductVersionLS)
  130.     End If
  131. End Property
  132.  
  133. Property Get FileVersionMajor() As Long
  134.     FileVersionMajor = fixed.dwFileVersionMS
  135. End Property
  136.  
  137. Property Get FileVersionMinor() As Long
  138.     FileVersionMinor = fixed.dwFileVersionLS
  139. End Property
  140.  
  141. Property Get ProductVersionMajor() As Long
  142.     ProductVersionMajor = fixed.dwProductVersionMS
  143. End Property
  144.  
  145. Property Get ProductVersionMinor() As Long
  146.     ProductVersionMinor = fixed.dwProductVersionLS
  147. End Property
  148.  
  149. Property Get BuildOptions() As Long
  150.     BuildOptions = fixed.dwFileFlags
  151. End Property
  152.  
  153. Property Get BuildString() As String
  154. With fixed
  155.     If sVer = sEmpty Then Exit Property
  156.     Dim s As String
  157.     If .dwFileFlags And VS_FF_DEBUG Then s = s & "Debug "
  158.     If .dwFileFlags And VS_FF_PRERELEASE Then s = s & "Prerelease "
  159.     If .dwFileFlags And VS_FF_PATCHED Then s = s & "Patched "
  160.     If .dwFileFlags And VS_FF_PRIVATEBUILD Then s = s & "PrivateBuild "
  161.     If .dwFileFlags And VS_FF_INFOINFERRED Then s = s & "InfoInferred "
  162.     If .dwFileFlags And VS_FF_SPECIALBUILD Then s = s & "SpecialBuild "
  163.     BuildString = s
  164. End With
  165. End Property
  166.  
  167. Property Get Environment() As String
  168.     If sVer = sEmpty Then Exit Property
  169.     Dim s As String
  170.     Select Case MBytes.LoWord(fixed.dwFileOS)
  171.     Case VOS__WINDOWS16
  172.         s = "Windows (16-bit)"
  173.     Case VOS__PM16
  174.         s = "PM (16-bit)"
  175.     Case VOS__PM32
  176.         s = "PM (32-bit)"
  177.     Case VOS__WINDOWS32
  178.         s = "Windows (32-bit)"
  179.     End Select
  180.     Select Case MBytes.HiWord(fixed.dwFileOS)
  181.     Case MBytes.HiWord(VOS_DOS)
  182.         s = s & " under MS-DOS"
  183.     Case MBytes.HiWord(VOS_OS216)
  184.         s = s & " under OS/2 (16-bit)"
  185.     Case MBytes.HiWord(VOS_OS232)
  186.         s = s & " under OS/2 (32-bit)"
  187.     Case MBytes.HiWord(VOS_NT)
  188.         s = s & " under Windows-NT"
  189.     End Select
  190.     Environment = s
  191. End Property
  192.  
  193. Property Get ExeType() As String
  194.     If sVer = sEmpty Then Exit Property
  195.     Dim s As String
  196.     Select Case fixed.dwFileType
  197.     Case VFT_APP:
  198.         s = "Application"
  199.     Case VFT_DLL:
  200.         s = "Dynamic Link Library"
  201.     Case VFT_DRV:
  202.         s = "Driver"
  203.         Select Case fixed.dwFileSubtype
  204.         Case VFT2_DRV_PRINTER
  205.             s = s & ":Printer"
  206.         Case VFT2_DRV_KEYBOARD
  207.             s = s & ":Keyboard"
  208.         Case VFT2_DRV_LANGUAGE
  209.             s = s & ":Language"
  210.         Case VFT2_DRV_DISPLAY
  211.             s = s & ":Display"
  212.         Case VFT2_DRV_MOUSE
  213.             s = s & ":Mouse"
  214.         Case VFT2_DRV_NETWORK
  215.             s = s & ":Network"
  216.         Case VFT2_DRV_SYSTEM
  217.             s = s & ":System"
  218.         Case VFT2_DRV_INSTALLABLE
  219.             s = s & ":Installable"
  220.         Case VFT2_DRV_SOUND
  221.             s = s & ":Sound"
  222.         Case VFT2_DRV_COMM
  223.             s = s & ":Communications"
  224.         End Select
  225.     Case VFT_FONT:
  226.         s = "Font"
  227.         Select Case fixed.dwFileSubtype
  228.         Case VFT2_FONT_RASTER
  229.             s = s & ":Raster"
  230.         Case VFT2_FONT_VECTOR
  231.             s = s & ":Vector"
  232.         Case VFT2_FONT_TRUETYPE
  233.             s = s & ":TrueType"
  234.         End Select
  235.     Case VFT_VXD:
  236.         s = "VXD"
  237.     Case VFT_STATIC_LIB:
  238.         s = "Static Library"
  239.     Case Else
  240.         s = "Unknown"
  241.     End Select
  242.     ExeType = s
  243. End Property
  244.  
  245. Property Get TimeStamp() As Date
  246.     Dim f As Boolean, ft As FILETIME, ftl As FILETIME, st As SYSTEMTIME
  247.     If fixed.dwFileDateMS = 0 And fixed.dwFileDateLS = 0 Then Exit Property
  248.     ft.dwHighDateTime = fixed.dwFileDateMS
  249.     ft.dwLowDateTime = fixed.dwFileDateLS
  250.     f = FileTimeToLocalFileTime(ft, ftl)
  251.     If f Then f = FileTimeToSystemTime(ftl, st)
  252.     If f = False Then Exit Property
  253.     TimeStamp = DateSerial(st.wYear, st.wMonth, st.wDay) + _
  254.                 TimeSerial(st.wHour, st.wMinute, st.wSecond)
  255. End Property
  256.  
  257. Property Get Company() As String
  258.     If sVer = sEmpty Then Exit Property
  259.     If VerQueryValue(sVer, sPrefix & "CompanyName", pData, cData) Then
  260.         Company = BufToStr(pData, cData)
  261.     End If
  262. End Property
  263.  
  264. Property Get Comments() As String
  265.     If sVer = sEmpty Then Exit Property
  266.     If VerQueryValue(sVer, sPrefix & "Comments", pData, cData) Then
  267.         Comments = BufToStr(pData, cData)
  268.     End If
  269. End Property
  270.  
  271. Property Get Description() As String
  272.     If sVer = sEmpty Then Exit Property
  273.     If VerQueryValue(sVer, sPrefix & "FileDescription", pData, cData) Then
  274.         Description = BufToStr(pData, cData)
  275.     End If
  276. End Property
  277.  
  278. Property Get ProductVersionString() As String
  279.     If sVer = sEmpty Then Exit Property
  280.     If VerQueryValue(sVer, sPrefix & "ProductVersion", pData, cData) Then
  281.         ProductVersionString = BufToStr(pData, cData)
  282.     End If
  283. End Property
  284.  
  285. Property Get FileVersionString() As String
  286.     If sVer = sEmpty Then Exit Property
  287.     If VerQueryValue(sVer, sPrefix & "FileVersion", pData, cData) Then
  288.         FileVersionString = BufToStr(pData, cData)
  289.     End If
  290. End Property
  291.  
  292.  
  293. Property Get InternalName() As String
  294.     If sVer = sEmpty Then Exit Property
  295.     If VerQueryValue(sVer, sPrefix & "InternalName", pData, cData) Then
  296.         InternalName = BufToStr(pData, cData)
  297.     End If
  298. End Property
  299.  
  300. Property Get Copyright() As String
  301.     If sVer = sEmpty Then Exit Property
  302.     If VerQueryValue(sVer, sPrefix & "LegalCopyright", pData, cData) Then
  303.         Copyright = BufToStr(pData, cData)
  304.     End If
  305. End Property
  306.  
  307. Property Get Trademarks() As String
  308.     If sVer = sEmpty Then Exit Property
  309.     If VerQueryValue(sVer, sPrefix & "LegalTradeMarks", pData, cData) Then
  310.         Trademarks = BufToStr(pData, cData)
  311.     End If
  312. End Property
  313.  
  314. Property Get OriginalFilename() As String
  315.     If sVer = sEmpty Then Exit Property
  316.     If VerQueryValue(sVer, sPrefix & "OriginalFilename", pData, cData) Then
  317.         OriginalFilename = BufToStr(pData, cData)
  318.     End If
  319. End Property
  320.  
  321. Property Get PrivateBuild() As String
  322.     If sVer = sEmpty Then Exit Property
  323.     If VerQueryValue(sVer, sPrefix & "PrivateBuild", pData, cData) Then
  324.         PrivateBuild = BufToStr(pData, cData)
  325.     End If
  326. End Property
  327.  
  328. Property Get ProductName() As String
  329.     If sVer = sEmpty Then Exit Property
  330.     If VerQueryValue(sVer, sPrefix & "ProductName", pData, cData) Then
  331.         ProductName = BufToStr(pData, cData)
  332.     End If
  333. End Property
  334.  
  335. Property Get ProductVersion() As String
  336.     If sVer = sEmpty Then Exit Property
  337.     If VerQueryValue(sVer, sPrefix & "ProductVersion", pData, cData) Then
  338.         ProductVersion = BufToStr(pData, cData)
  339.     End If
  340. End Property
  341.  
  342. Property Get SpecialBuild() As String
  343.     If sVer = sEmpty Then Exit Property
  344.     If VerQueryValue(sVer, sPrefix & "SpecialBuild", pData, cData) Then
  345.         SpecialBuild = BufToStr(pData, cData)
  346.     End If
  347. End Property
  348.  
  349. Property Get Custom(sCustom As String) As String
  350.     If sVer = sEmpty Then Exit Property
  351.     If VerQueryValue(sVer, sPrefix & sCustom, pData, cData) Then
  352.         Custom = BufToStr(pData, cData)
  353.     End If
  354. End Property
  355.  
  356. #If fComponent = 0 Then
  357. Private Sub ErrRaise(e As Long)
  358.     Dim sText As String, sSource As String
  359.     If e > 1000 Then
  360.         sSource = App.ExeName & ".Version"
  361.         Select Case e
  362.         Case eeBaseVersion
  363.             BugAssert True
  364.        ' Case ee...
  365.        '     Add additional errors
  366.         End Select
  367.         Err.Raise COMError(e), sSource, sText
  368.     Else
  369.         ' Raise standard Visual Basic error
  370.         sSource = App.ExeName & ".VBError"
  371.         Err.Raise e, sSource
  372.     End If
  373. End Sub
  374. #End If
  375.  
  376.